El objetivo es analizar un grafo, que se provee como fichero en el mismo paquete que este enunciado. En este fichero, encontramos solamente dos columnas, correspondiente a una interacción entre dos nodos de la red. Esta red está formada por distintos individuos que tienen contactos cara a cara durante un período de tiempo.

A continuación, dividimos la práctica en apartados, con una breve descripción de qué debe contener cada chunk de código donde el alumno desarrollará su respuesta así como las explicaciones que considere oportunas. Por favor, razona todas tus soluciones y escribe las explicaciones en azul.

Junto al título de cada apartado se encuentra la puntuación del mismo (pueden obtenerse hasta 10,5 puntos, aunque solamente se evaluará del 0 al 10).

Carga de datos y comprobaciones iniciales (0,5 puntos)

En este apartado, se pide:

### Inserta aqui tu codigo
# Suprimir mensajes de carga de paquetes
suppressPackageStartupMessages(library(igraph))
# Cargaa del fichero
library(data.table)
data_red <- fread("red_contactos.csv", sep =  ";", col.names =c("origen", "destino"))

# Carga como grafo
library(igraph)

# graph
g_base <- graph_from_data_frame(data_red, directed = FALSE)

#install.packages('glue')
library(glue)
print(glue("Tenemos {vcount(g_base)} nodos y {gsize(g_base)} enlaces en nuestro grafo base."))
## Tenemos 1390 nodos y 222744 enlaces en nuestro grafo base.
# Creo una columna 'weight' con valor 1 por enlace.
E(g_base)$weight <- 1

# Agrupo los enlaces por su peso 'weight' y elimino los enlaces propios.
g <- simplify(g_base, edge.attr.comb = "sum", remove.loops=TRUE)

# Verifico el resultado
print(glue("Pasamos a tener {gsize(g)} enlaces despúes de realizar un simplify en nuestro grafo base."))
## Pasamos a tener 53942 enlaces despúes de realizar un simplify en nuestro grafo base.
# Pesos de los enlaces en el grafo consolidado
link_weights <- edge_attr(g, "weight")

# Estadisticos basicos de los enlaces entre nodos.
summary(link_weights)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   1.000   2.000   2.000   3.395   3.000 155.000

Selección de la componente conexa mayor (0,5 puntos)

En este apartado, se pide realizar los pasos adecuados para generar un nuevo objeto grafo, que sea conexo, y que involucre a todos los nodos y enlaces de la componente conexa mayor del grafo original.

### Inserta aqui tu codigo

# Identificar la componente conexa mayor del grafo original
cc <- components(g)

# Tenemos 3 clusters, casi todos los nodos estan continidos en el primer cluster
head(cc$csize)
## [1] 1388    1    1
# Identifico el grupo con mayor numeor de nodos.
cc_max <- which.max(cc$csize)

# Nodos de la componente conexa mayor
cc_conexa <- which(cc$membership == cc_max)

# Links de la componente conexa mayor
g2 <- induced_subgraph(g, cc_conexa)
print(glue("Número de nodos de la componente conexa mayor {vcount(g2)}. \nConectadas: {is_connected(g2)}"))
## Número de nodos de la componente conexa mayor 1388. 
## Conectadas: TRUE

Análisis descriptivo de la componente conexa mayor (2,5 puntos)

En este apartado, se pide analizar descriptivamente el grafo usando los conceptos que hemos visto durante las clases de teoría:

### Inserta aqui tu codigo

# Grado medio
mean_degree <- mean(degree(g2))
nodos <- vcount(g2)
prop_conex <- (mean_degree/nodos)*100

print(glue("En promedio, cada nodo en el grafo tiene aproximadamente {round(mean_degree)} conexiones con otros nodos."))
## En promedio, cada nodo en el grafo tiene aproximadamente 78 conexiones con otros nodos.
print(glue("En promedio, cada nodo está conectado al {round(prop_conex, 3)} % de todos los nodos en la red."))
## En promedio, cada nodo está conectado al 5.6 % de todos los nodos en la red.
# Distancia media
mean_distance <- mean_distance(g2)
print(glue("Distancia media entre los nodos es de {round(mean_distance,2)}. Esto implica que, en general, los nodos están bastante cerca entre sí y que la red es relativamente compacta."))
## Distancia media entre los nodos es de 3.07. Esto implica que, en general, los nodos están bastante cerca entre sí y que la red es relativamente compacta.
# Diámetro
diameter <- diameter(g2)
print(glue("La distancia más larga entre dos nodos en tu grafo es de {diameter}. Lo cual indica que no hay ningún nodo más lejos de eso."))
## La distancia más larga entre dos nodos en tu grafo es de 14. Lo cual indica que no hay ningún nodo más lejos de eso.
# Distribución de grados y ajuste a una Power-Law
degs <- degree(g2)

# Cómo podemos observar de los 1388 nodos del grafo los 120 primeros tienen el 80% de las conexiones del grafo.
hist(degs, breaks = 30, main = "Distribución de grados", xlab = "Grado", ylab = "Frecuencia")

# Esto reafirma lo anterior, los grados altos se concentran entorno a los 120 nodos.
plot(density(degs), log ="xy")
## Warning in xy.coords(x, y, xlabel, ylabel, log): 38 x values <= 0 omitted from
## logarithmic plot

# Clustering
clustering_coef <- mean(transitivity(g2))
print(glue(" La proporción de conexiones entre los vecinos de un nodo en relación con todas las posibles conexiones entre esos vecinos es de {round((clustering_coef*100),2)}%. Lo cual indica que se trata de un red cohesionada."))
##  La proporción de conexiones entre los vecinos de un nodo en relación con todas las posibles conexiones entre esos vecinos es de 20.58%. Lo cual indica que se trata de un red cohesionada.
# Entropía de los nodos

# Distribución de grados del grafo
degree_distribution <- table(degree(g2))

# Proporción de nodos para cada grado
degree_distribution <- degree_distribution / sum(degree_distribution)

# Entropía
entropy <- sum(degree_distribution * log(degree_distribution))

# print la entropía
print(glue("La entropía de los nodos es de {round(entropy,3)}. Lo cual sugiere que la distribución de grados está bastante concentrada, cómo veniamos comentando anteriormente."))
## La entropía de los nodos es de -5.097. Lo cual sugiere que la distribución de grados está bastante concentrada, cómo veniamos comentando anteriormente.
# Centralidad de los nodos y comparación con métricas de grado y clustering
centrality <- centr_degree(g2)$centralization
print(glue("La centralidad de los nodos es de {round((centrality*100),3)}%, lo cual indica que un 1/4 de los nodos en el grafo tienen un número significativamente mayor de conexiones en comparación con el resto de los nodos."))
## La centralidad de los nodos es de 25.687%, lo cual indica que un 1/4 de los nodos en el grafo tienen un número significativamente mayor de conexiones en comparación con el resto de los nodos.

Análisis de comunidades de la componente conexa mayor (1,5 puntos)

En este apartado, se pide aplicar dos algoritmos de detección de comunidades, compararlos y seleccionar cuál es, en tu opinión, el que da una mejor respuesta. Razona tu selección.

### Inserta aqui tu codigo

# Algoritmo de Louvain: algoritmo de particionamiento de grafos que busca maximizar la modularidad de la red al agrupar los nodos en comunidades densamente conectadas.
# La resolución determina el nivel de escala al que se forman las comunidades.
louvain_clusters <- cluster_louvain(g2,  weights = NULL, resolution = 0.3)

# Calcular la modularidad de ambos métodos
modularity_louvain <- modularity(louvain_clusters)

# print modularidad
print(glue("La modularidad del algoritmo de Louvain es de {round(modularity_louvain,3)}"))
## La modularidad del algoritmo de Louvain es de 0.711
# Configurar el tamaño y color de los nodos
color_nodos <- rainbow(max(membership(louvain_clusters)))

# Configurar la disposición del grafo
layout <- layout_with_fr(g2)

# Visualización mejorada
plot(
  louvain_clusters, g2, 
  layout = layout, 
  vertex.size = 5, 
  vertex.color = color_nodos, 
  vertex.label = NA, 
  edge.color = "gray", 
  main = "Comunidades detectadas por Louvain"
)

Visualización del grafo por comunidades de la componente conexa mayor (1,5 puntos)

En este apartado, se pide visualizar el grafo coloreando cada nodo en función de la comunidad a la que pertenezca, según tu elección del apartado anterior.

### Inserta aqui tu codigo
ll <- layout.fruchterman.reingold(g2)

plot(g2, vertex.label = NA, 
     vertex.color = color_nodos, 
     layout = ll,
     edge.width = 1,
     edge.color = "gray",
     vertex.size = (log(degree(g2))+1),
     asp = 0.6)

Difundiendo un rumor (o un virus) en la componente conexa mayor (4 puntos)

Este apartado es el que más peso en la práctica tiene. Vamos a implementar un modelo epidemiológico sobre el grafo que, típicamente, se utiliza para simular escenarios de difusión de enfermedades pero también en contextos como la distribución de rumoeres e información. Vamos a implementar un modelo SIR que se caracteriza por tener los siguientes parámetros:

Se pide desarrollar una función que tenga como parámetros los tres valores anteriores y un cuarto que sea un grafo que, en nuestro caso, será la componente conexa mayor del grafo original de esta práctica. Dicha función simulará el proceso SIR:

Se pide ejecutar una simulación para tres o cuatro valores del parámetro beta (N y gamma pueden ser fijos en estas simulaciones) de este proceso de manera que se pueda visualizar:

library(igraph)

# Función para simular el modelo SIR en un grafo
simular_SIR <- function(N, beta, gamma, graph) {
  node_states <- rep(0, vcount(graph))  # Todos son susceptibles de contagiarse
  initial_infected <- sample(1:vcount(graph), N) # N random nodos contagiados al inicio
  node_states[initial_infected] <- 1
  
  new_infected <- vector()
  contagion_graphs <- list()
  contagion_graph <- make_empty_graph(vcount(graph), directed = TRUE)
  
  # Iteración 0 con los primeros contagiados
  contagion_graphs[[1]] <- list(
    contagion_graph = contagion_graph,
    node_states = node_states
  )
  
  stop_not_infected <- 0
  iter <- 2  # Empiezo por la iteración en 2 para que la 1 sea la inicial con contagiados
  
  while (stop_not_infected < 3) {
    current_new_infected <- 0
    
    for (node in 1:vcount(graph)) {
      if (node_states[node] == 0) {
        # si el nodo tiene algun vecino 0 tiene una probabilidad de contagiarse
        # esta probabilidad es aleatoria, si supera beta entonces se contagia.
        neighbors <- neighbors(graph, node)
        if (length(neighbors) > 0 && any(node_states[neighbors] == 1)) {
          for (neighbor in neighbors) {
            if (node_states[neighbor] == 1 && runif(1) < beta) {
              node_states[node] <- 1  
              current_new_infected <- current_new_infected + 1
              contagion_graph <- add_edges(contagion_graph, c(neighbor, node))
              break
            }
          }
        }
        # Si ya esta contagiado tiene una probabilidad de recuperarse aleatoria si supera gamma.
      } else if (node_states[node] == 1) {
        if (runif(1) < gamma) {
          node_states[node] <- 2  
        }
      }
    }
    # almacenamos los resultados.
    new_infected <- c(new_infected, current_new_infected)
    contagion_graphs[[iter]] <- list(
      contagion_graph = contagion_graph,
      node_states = node_states
    )
    
    # si no hay nuevos contagiados se suma 1,
    if (current_new_infected == 0) {
      stop_not_infected <- stop_not_infected + 1
    } else {
      stop_not_infected <- 0
    }
    
    iter <- iter + 1
  }
  
  # Lista con los resultados totales.
  list(
    new_infected = new_infected, 
    contagion_graphs = contagion_graphs,
    initial_infected = initial_infected
  )
}

# Parámetros de la simulación
N <- 5
betas <- c(0.3, 0.5, 0.7, 0.9)
gamma <- 0.1

# Resultados
results <- lapply(betas, function(beta) {
  list(beta = beta, result = simular_SIR(N, beta, gamma, g2))
})

# Curva de nuevos infectados en escala logarítmica
par(mfrow=c(2,2))
for (i in 1:length(results)) {
  new_infected <- results[[i]]$result$new_infected
  plot(log1p(new_infected), type="o", main=paste("Beta =", results[[i]]$beta),
       xlab="Iteración", ylab="Nuevos Infectados (log escala)")
}

# Crear una carpeta para las imágenes
dir.create("img", showWarnings = FALSE)


# Grafo de contagios en cada iteración
img <- 1
for (i in 1:length(results)) {
  beta <- results[[i]]$beta
  contagion_graphs <- results[[i]]$result$contagion_graphs
  initial_infected <- results[[i]]$result$initial_infected
  
  for (j in 1:(length(contagion_graphs))) {  
    contagion_graph <- contagion_graphs[[j]]$contagion_graph
    node_states <- contagion_graphs[[j]]$node_states
    
    V(contagion_graph)$color <- ifelse(node_states == 1, "red",ifelse(node_states == 2, "green", "white"))
    V(contagion_graph)$color[initial_infected] <- "blue"
    
    filename <- paste("img/",img ,".png", sep="")
    png(filename, width = 1200, height = 800)
    plot(contagion_graph, main=paste("Beta =", beta, "Iteración =", j - 1),
         vertex.label=NA, vertex.size=5, edge.arrow.size=0.5, layout = layout)
    dev.off()
    
    img <- img + 1
    }
}
library(magick)
## Linking to ImageMagick 6.9.12.93
## Enabled features: cairo, fontconfig, freetype, heic, lcms, pango, raw, rsvg, webp
## Disabled features: fftw, ghostscript, x11
# Directorio de salida
dir_out <- "img/"

# nombres de los archivos de las imágenes
imgs <- list.files(dir_out, full.names = TRUE)

# Me quedo con los numeros remplazando todo lo que no sea un digito por un vacio.
file_numbers <- as.numeric(gsub("\\D", "", basename(imgs)))

# Padear los números con ceros a la izquierda para asegurar el orden correcto
file_with_0_numbers <- sprintf("%03d", file_numbers)

# Data frame con los nombres originales y los nuevos
files_df <- data.frame(
  original = imgs,
  nuevos = file.path(dirname(imgs), paste0(file_with_0_numbers, ".png"))
)

# Orden por los nuevos nombres
files_df <- files_df[order(files_df$nuevos), ]

# Lectura de las imágenes en el orden correcto
img_list <- lapply(files_df$original, image_read)

# Unir las imágenes juntas
img_joined <- image_join(img_list)

# Animar a 2 fotogramas por segundo
gif<- image_animate(img_joined, fps = 2)

# Gif
print(gif)
##    format width height colorspace matte filesize density
## 1     gif  1200    800       sRGB  TRUE        0   72x72
## 2     gif  1200    800       sRGB  TRUE        0   72x72
## 3     gif  1200    800       sRGB  TRUE        0   72x72
## 4     gif  1200    800       sRGB  TRUE        0   72x72
## 5     gif  1200    800       sRGB  TRUE        0   72x72
## 6     gif  1200    800       sRGB  TRUE        0   72x72
## 7     gif  1200    800       sRGB  TRUE        0   72x72
## 8     gif  1200    800       sRGB  TRUE        0   72x72
## 9     gif  1200    800       sRGB  TRUE        0   72x72
## 10    gif  1200    800       sRGB  TRUE        0   72x72
## 11    gif  1200    800       sRGB  TRUE        0   72x72
## 12    gif  1200    800       sRGB  TRUE        0   72x72
## 13    gif  1200    800       sRGB  TRUE        0   72x72
## 14    gif  1200    800       sRGB  TRUE        0   72x72
## 15    gif  1200    800       sRGB  TRUE        0   72x72
## 16    gif  1200    800       sRGB  TRUE        0   72x72
## 17    gif  1200    800       sRGB  TRUE        0   72x72
## 18    gif  1200    800       sRGB  TRUE        0   72x72
## 19    gif  1200    800       sRGB  TRUE        0   72x72
## 20    gif  1200    800       sRGB  TRUE        0   72x72
## 21    gif  1200    800       sRGB  TRUE        0   72x72
## 22    gif  1200    800       sRGB  TRUE        0   72x72
## 23    gif  1200    800       sRGB  TRUE        0   72x72
## 24    gif  1200    800       sRGB  TRUE        0   72x72
## 25    gif  1200    800       sRGB  TRUE        0   72x72
## 26    gif  1200    800       sRGB  TRUE        0   72x72
## 27    gif  1200    800       sRGB  TRUE        0   72x72
## 28    gif  1200    800       sRGB  TRUE        0   72x72
## 29    gif  1200    800       sRGB  TRUE        0   72x72
## 30    gif  1200    800       sRGB  TRUE        0   72x72
## 31    gif  1200    800       sRGB  TRUE        0   72x72
## 32    gif  1200    800       sRGB  TRUE        0   72x72
## 33    gif  1200    800       sRGB  TRUE        0   72x72
## 34    gif  1200    800       sRGB  TRUE        0   72x72
## 35    gif  1200    800       sRGB  TRUE        0   72x72
## 36    gif  1200    800       sRGB  TRUE        0   72x72
## 37    gif  1200    800       sRGB  TRUE        0   72x72
## 38    gif  1200    800       sRGB  TRUE        0   72x72
## 39    gif  1200    800       sRGB  TRUE        0   72x72
## 40    gif  1200    800       sRGB  TRUE        0   72x72
## 41    gif  1200    800       sRGB  TRUE        0   72x72
## 42    gif  1200    800       sRGB  TRUE        0   72x72

# Guardar en el disco
image_write(image = gif, path = "resultados.gif")